home *** CD-ROM | disk | FTP | other *** search
/ BBS in a Box 4 / BBS in a Box - Macintosh - Volume IV (January 1992) (BBS in a Box).iso / Files / Prog / T / TurtleGraphicsAssit1.0 < prev   
Encoding:
Text File  |  1987-07-26  |  22.6 KB  |  814 lines  |  [TEXT/MACA]
  1. ;*
  2. ;* 
  3. ;*  Program Name:  Turtle Assistant V1.0
  4. ;*  Date Written:  July 26, 1987 
  5. ;*  Author:        Christopher J. Flynn
  6. ;*                 2601 Claxton Drive 
  7. ;*                 Herndon, VA 22071 
  8. ;*  Description: 
  9. ;*    Turtle Assistant introduces Logo newcomers to turtle graphics.
  10. ;*    A control panel places common turtle commands within reach of a
  11. ;*    button click.  Other options are available via menus.  Multiple
  12. ;*    turtle drawing windows are suported.
  13. ;*       
  14.  
  15.  
  16. ;
  17. ;  G L O B A L    V A R I A B L E S
  18. ;
  19. make "Black [255 255 255 255 255 255 255 255]
  20. make "White [0 0 0 0 0 0 0 0]
  21. make "Gray [170 85 170 85 170 85 170 85]
  22. make "LtGray [136 34 136 34 136 34 136 34]
  23. make "DkGray [119 221 119 221 119 221 119 221]
  24. make "Bricks [128 128 128 255 8 8 8 255]
  25. make "Weave [248 116 34 71 143 23 34 113]
  26. make "Marbles [119 137 143 143 119 152 248 248]
  27. make "Waffles [191 192 191 191 176 176 176 176]
  28.  
  29.  
  30.  
  31. make "CurrentTurtleWindow []
  32. make "TurtleWindowID 0
  33.  
  34. ;
  35. ;  H O U S E K E E P I N G    P R O C E D U R E S
  36. ;
  37.  
  38. ;
  39. ;  Procedure to clear/restore desktop when program is started/stopped
  40. ;
  41. to Go
  42.   CleanUpToStart Windows
  43.   InstallNewMenu
  44.   make "ControlPanel (oneof :ControlWindow "ProcID 3)
  45.   ask :ControlPanel [WSelect]
  46. end
  47.  
  48. to CleanUpToStart :AllWindows
  49.   if EmptyP :AllWindows [stop]
  50.   LocalMake "W first :AllWindows
  51.   ifelse or (MemberP :W Listeners) (MemberP :W FileWindows)
  52. _   [ask :W [HaveMake "HoldPos WPos SetWPos ScreenSize]]
  53. _   [ask :W [if ChangedP [SetWPos [5 40] WSelect] WClose]]
  54.   CleanUpToStart butfirst :AllWindows
  55. end
  56.  
  57. to CleanUpToQuit :AllWindows
  58.   if EmptyP :AllWindows [stop]
  59.   LocalMake "W first :AllWindows
  60.   ifelse or (MemberP :W Listeners) (MemberP :W FileWindows)
  61. _   [ask :W [SetWPos :HoldPos  EraseName "HoldPos]]
  62. _   [ask :W [WSelect WClose]]
  63.   CleanUpToQuit butfirst :AllWindows
  64. end
  65.  
  66.  
  67. ;
  68. ;  D E F I N E    M E N U    O B J E C T S
  69. ;
  70.  
  71. ;
  72. ;  Apple Menu
  73. ;
  74. make "HoldAppleMenu first Menus
  75. make "NewAppleMenu oneof Menu
  76. ask :NewAppleMenu [SetTitle ask :HoldAppleMenu [Title]]
  77. ask :NewAppleMenu [SetUpItems [
  78. _   |About TA|
  79. _     [Ignore (Dialog
  80. _     "|Turtle Assistant Version 1.0 - an Object Logo Program by Chris Flynn.|
  81. _     [OK])]]]
  82. make "AppleMenuItems butfirst ask :HoldAppleMenu [ItemList]
  83. while [not EmptyP :AppleMenuItems]
  84. _   [ask :NewAppleMenu [AddItem first :AppleMenuItems]
  85. _    make "AppleMenuItems butfirst :AppleMenuItems]
  86.  
  87. ;
  88. ;  File Menu
  89. ;
  90. make "FileMenu oneof Menu
  91. ask :FileMenu [SetTitle "File]
  92. ask :FileMenu [SetUpItems [
  93. _    |New/N|  [MakeNewWindow]
  94. _    |Print/P| [DoPrint]
  95. _    |Quit/Q| [DoQuit]]]
  96.  
  97. ;
  98. ;  Edit Menu
  99. ;
  100. make "EditMenu oneof Menu
  101. ask :EditMenu [SetTitle "Edit]
  102. ask :EditMenu [SetUpItems [
  103. _   |Undo/Z| [ask ActionWindow [Undo]]
  104. _   |(-| []
  105. _   |Cut/X| [ask ActionWindow [Cut]]
  106. _   |Copy/C| [ask ActionWindow [Copy]]
  107. _   |Paste/V| [ask ActionWindow [Paste]]
  108. _   |Clear| [ask ActionWindow [Clear]]
  109. _   |Select All/A| [ask ActionWindow [SetSelection list 0 TextLength]]]
  110.  
  111. ask :EditMenu [to Update]
  112.   ifelse EqualP (ask first windows [:class]) "Desk.Accessory
  113. _   [Enable]
  114. _   [Disable]
  115. end
  116.  
  117. ;
  118. ;-------- Recorder Menu
  119. ;
  120. make "RecorderMenu oneof Menu
  121. ask :RecorderMenu [SetTitle "Recorder]
  122.  
  123. make "OnMenuItem kindof MenuItem
  124. ask :OnMenuItem [to Exist]
  125.   Usual.Exist
  126.   SetTitle "On
  127.   SetAction [RecorderOn]
  128. end
  129.  
  130. ask :OnMenuItem [to Update]
  131.   if EmptyP :CurrentTurtleWindow [stop]
  132.   ifelse ask :CurrentTurtleWindow [:RecordingP]
  133. _   [Check]
  134. _   [UnCheck]
  135. end
  136.  
  137. make "OffMenuItem kindof MenuItem
  138. ask :OffMenuItem [to Exist]
  139.   Usual.Exist
  140.   SetTitle "Off
  141.   SetAction [RecorderOff]
  142. end
  143.  
  144. ask :OffMenuItem [to Update]
  145.   if EmptyP :CurrentTurtleWindow [stop]
  146.   ifelse ask :CurrentTurtleWindow [:RecordingP]
  147. _   [Uncheck]
  148. _   [Check]
  149. end
  150.  
  151. make "EraseMenuItem kindof MenuItem
  152. ask :EraseMenuItem [to Exist]
  153.   Usual.Exist
  154.   SetTitle "Erase
  155.   SetAction [RecorderErase]
  156. end
  157.  
  158. ask :EraseMenuItem [to Update]
  159. end
  160.  
  161. make "PlayBackMenuItem kindof MenuItem
  162. ask :PlayBackMenuItem [to Exist]
  163.   Usual.Exist
  164.   SetTitle "Playback
  165.   setAction [RecorderPlayBack]
  166. end
  167.  
  168. ask :PlayBackMenuItem [to Update]
  169. end
  170.  
  171. ask :RecorderMenu [AddItem oneof :OnMenuItem]
  172. ask :RecorderMenu [AddItem oneof :OffMenuItem]
  173. ask :RecorderMenu [AddItem (oneof MenuItem "Title "|(-|)]
  174. ask :RecorderMenu [AddItem oneof :EraseMenuItem]
  175. ask :RecorderMenu [AddItem (oneof MenuItem "Title "|(-|)]
  176. ask :RecorderMenu [AddItem oneof :PlayBackMenuItem]
  177.  
  178. to RecorderOn
  179.   ask :CurrentTurtleWindow [HaveMake "RecordingP "True]
  180. end
  181.  
  182. to RecorderOff
  183.   ask :CurrentTurtleWindow [HaveMake "RecordingP "False]
  184. end
  185.  
  186. to RecorderErase
  187.   ask :CurrentTurtleWindow [HaveMake "DrawingHistory []]
  188. end
  189.  
  190. to RecorderPlayBack
  191.   LocalMake "AllCommands ask :CurrentTurtleWindow [:DrawingHistory]
  192.   LocalMake "ATurtle first ask :CurrentTurtleWindow [Turtles]
  193.   if EmptyP :AllCommands [stop]
  194.   LocalMake "Result GetNumber
  195.   if or (EqualP first :Result "Cancel)
  196. _       (not NumberP last :Result)
  197. _   [stop]
  198.   LocalMake "NTimes last :Result
  199.   RunTheCommands :NTimes :ATurtle :AllCommands
  200. end
  201.  
  202. to RunTheCommands :RepeatCount :TheTurtle :CommandList
  203.   Define "TurtleCommands (list [] :CommandList)
  204.   Repeat :RepeatCount [ask :TheTurtle [TurtleCommands]]
  205. end
  206.  
  207.  
  208. ;
  209. ;-------- Turtle Menu
  210. ;
  211. make "TurtleMenu oneof Menu
  212. ask :TurtleMenu [SetTitle "Turtle]
  213.  
  214. make "ShowTurtleMenuItem kindof MenuItem
  215. ask :ShowTurtleMenuItem [to Exist]
  216.   Usual.Exist
  217.   if EqualP first :InitList "Turtle
  218. _   [SetTitle last :InitList]
  219.   SetAction [SetTurtle]
  220. end
  221.  
  222. make "HideTurtleMenuItem kindof MenuItem
  223. ask :HideTurtleMenuItem [to Exist]
  224.   Usual.Exist
  225.   if EqualP first :InitList "Turtle
  226. _   [SetTitle last :InitList]
  227.   SetAction [SetTurtle]
  228. end
  229.  
  230. ask :ShowTurtleMenuItem [to Update]
  231.   if EmptyP :CurrentTurtleWindow [stop]
  232.   LocalMake "ATurtle first ask :CurrentTurtleWindow [Turtles]
  233.   ifelse and (EqualP Title "Show) 
  234. _            (ask :ATurtle [ShownP])
  235. _   [Check]
  236. _   [UnCheck]
  237. end
  238.  
  239. ask :HideTurtleMenuItem [to Update]
  240.   if EmptyP :CurrentTurtleWindow [stop]
  241.   LocalMake "ATurtle first ask :CurrentTurtleWindow [Turtles]
  242.   ifelse and (EqualP Title "Hide) 
  243. _            (not ask :ATurtle [ShownP])
  244. _   [Check]
  245. _   [UnCheck]
  246. end
  247.  
  248. ask :TurtleMenu [AddItem (oneof :ShowTurtleMenuItem "Turtle "Show)]
  249. ask :TurtleMenu [AddItem (oneof :HideTurtleMenuItem "Turtle "Hide)]
  250.  
  251. to SetTurtle
  252.   LocalMake "ATurtle first ask :CurrentTurtleWindow [Turtles]
  253.   LocalMake "ShowOrHide ask ActionMenuItem [Title]
  254.   ifelse Equalp :ShowOrHide "Show
  255. _   [ask :ATurtle [ShowTurtle]]
  256. _   [ask :ATurtle [HideTurtle]] 
  257.   ask :CurrentTurtleWindow [SaveIt word :ShowOrHide "Turtle]
  258. end
  259.  
  260.  
  261. ;
  262. ;-------- PenPattern Menu
  263. ;
  264. make "PatternMenu oneof Menu
  265. ask :PatternMenu [SetTitle "Pattern]
  266.  
  267. make "PatternItem kindof MenuItem
  268. ask :PatternItem [to Exist]
  269.   Usual.Exist
  270.   SetTitle Item 2 :InitList
  271.   HaveMake "PatternName Item 2 :InitList
  272.   HaveMake "PatternValue Item 4 :InitList
  273.   SetAction [SetThePattern]
  274. end
  275.  
  276. ask :PatternItem [to Update]
  277.   if EmptyP :CurrentTurtleWindow [stop]
  278.   ifelse EqualP (ask :CurrentTurtleWindow [:MyPattern]) :PatternName
  279. _   [Check]
  280. _   [UnCheck]
  281. end
  282.  
  283. ask :PatternMenu [AddItem (oneof :PatternItem "Name "Black "Val :Black)]
  284. ask :PatternMenu [AddItem (oneof :PatternItem "Name "White "Val :White)]
  285. ask :PatternMenu [AddItem (oneof :PatternItem "Name "Gray "Val :Gray)]
  286. ask :PatternMenu [AddItem (oneof :PatternItem "Name "LtGray "Val :LtGray)]
  287. ask :PatternMenu [AddItem (oneof :PatternItem "Name "DkGray "Val :DkGray)]
  288. ask :PatternMenu [AddItem (oneof :PatternItem "Name "Bricks "Val :Bricks)]
  289. ask :PatternMenu [AddItem (oneof :PatternItem "Name "Weave "Val :Weave)]
  290. ask :PatternMenu [AddItem (oneof :PatternItem "Name "Marbles "Val :Marbles)]
  291. ask :PatternMenu [AddItem (oneof :PatternItem "Name "Waffles "Val :Waffles)]
  292.  
  293. to SetThePattern
  294.   LocalMake "PatternPicked ask ActionMenuItem [:PatternName]
  295.   Localmake "ValuePicked ask ActionMenuItem [:PatternValue]
  296.   LocalMake "ATurtle first ask :CurrentTurtleWindow [Turtles]
  297.   ask :CurrentTurtleWindow [HaveMake "MyPattern :PatternPicked]
  298.   ask :ATurtle [SetPenPattern :ValuePicked]
  299.   ask :CurrentTurtleWindow [SaveIt "SetPenPattern]
  300.   ask :CurrentTurtleWindow [SaveIt :ValuePicked]
  301. end
  302.  
  303.  
  304. ;
  305. ;-------- PenMode Menu
  306. ;
  307. make "PenModeMenu oneof Menu
  308. ask :PenModeMenu [SetTitle "Pen]
  309.  
  310. make "PenModeItem kindof MenuItem
  311. ask :PenModeItem [to Exist]
  312.   Usual.Exist
  313.   if EqualP first :InitList "PenMode
  314. _   [SetTitle last :InitList]
  315.   SetAction [SetThePenMode]
  316. end
  317.  
  318. ask :PenModeItem [to Update]
  319.   if EmptyP :CurrentTurtleWindow [stop]
  320.   ifelse EqualP Title (ask :CurrentTurtleWindow [PenMode])
  321. _   [Check]
  322. _   [UnCheck]
  323. end
  324.  
  325. ask :PenModeMenu [AddItem (oneof :PenModeItem "PenMode "Up)]
  326. ask :PenModeMenu [AddItem (oneof :PenModeItem "PenMode "Down)]
  327. ask :PenModeMenu [AddItem (oneof MenuItem "Title "|(-|)]
  328. ask :PenModeMenu [AddItem (oneof :PenModeItem "PenMode "Erase)]
  329. ask :PenModeMenu [AddItem (oneof :PenModeItem "PenMode "Paint)]
  330. ask :PenModeMenu [AddItem (oneof :PenModeItem "PenMode "Reverse)]
  331. ask :PenModeMenu [AddItem (oneof MenuItem "Title "|(-|)]
  332. ask :PenModeMenu [AddItem (oneof :PenModeItem "PenMode "DownNot)]
  333. ask :PenModeMenu [AddItem (oneof :PenModeItem "PenMode "EraseNot)]
  334. ask :PenModeMenu [AddItem (oneof :PenModeItem "PenMode "PaintNot)]
  335. ask :PenModeMenu [AddItem (oneof :PenModeItem "PenMode "ReverseNot)]
  336.  
  337. to SetThePenMode
  338.   LocalMake "ThePenMode ask ActionMenuItem [Title]
  339.   LocalMake "ATurtle first ask :CurrentTurtleWindow [Turtles]
  340.   ask :ATurtle [SetPenMode :ThePenMode]
  341.   ask :CurrentTurtleWindow [SaveIt "SetPenMode]
  342.   ask :CurrentTurtleWindow [SaveIt :ThePenMode]
  343. end
  344.  
  345.  
  346. ;
  347. ;-------- PenSize Menu - Preset for some typical pensize configurations
  348. ;
  349. make "PenSizeMenu oneof Menu
  350. ask :PenSizeMenu [SetTitle "PenSize]
  351.  
  352. make "PenSizeMenuItem kindof MenuItem
  353. ask :PenSizeMenuItem [to exist]
  354.   Usual.Exist
  355.   ifelse EqualP first :InitList "Size
  356. _   [HaveMake "MyPenSize last :InitList]
  357. _   [HaveMake "MyPenSize [1 1]]
  358.   SetTitle (word first :MyPenSize "| by | last :MyPenSize)
  359.   SetAction [SetThePenSize]
  360. end
  361.  
  362. ask :PenSizeMenuItem [to Update]
  363.   if EmptyP :CurrentTurtleWindow [stop]
  364.   ifelse EqualP :MyPenSize ask :CurrentTurtleWindow [PenSize]
  365. _   [Check]
  366. _   [UnCheck]
  367. end
  368.  
  369. make "WSizeMenuItem kindof MenuItem
  370. ask :WSizeMenuItem [to Exist]
  371.   Usual.Exist
  372.   SetTitle "|Pen Width|
  373.   SetAction [SetThePenWidth]
  374. end
  375.  
  376. ask :WSizeMenuItem [to Update]
  377. end
  378.  
  379. make "HSizeMenuItem kindof MenuItem
  380. ask :HSizeMenuItem [to Exist]
  381.   Usual.Exist
  382.   SetTitle "|Pen Height|
  383.   SetAction [SetThePenHeight]
  384. end
  385.  
  386. ask :HSizeMenuItem [to Update]
  387. end
  388.  
  389. ask :PenSizeMenu [AddItem (oneof :PenSizeMenuItem "Size [1 1])]
  390. ask :PenSizeMenu [AddItem (oneof :PenSizeMenuItem "Size [2 2])]
  391. ask :PenSizeMenu [AddItem (oneof :PenSizeMenuItem "Size [3 3])]
  392. ask :PenSizeMenu [AddItem (oneof :PenSizeMenuItem "Size [4 4])]
  393. ask :PenSizeMenu [AddItem (oneof :PenSizeMenuItem "Size [5 5])]
  394. ask :PenSizeMenu [AddItem (oneof :PenSizeMenuItem "Size [6 6])]
  395. ask :PenSizeMenu [AddItem (oneof :PenSizeMenuItem "Size [7 7])]
  396. ask :PenSizeMenu [AddItem (oneof :PenSizeMenuItem "Size [8 8])]
  397. ask :PenSizeMenu [AddItem (oneof :PenSizeMenuItem "Size [9 9])]
  398. ask :PenSizeMenu [AddItem (oneof :PenSizeMenuItem "Size [10 10])]
  399. ask :PenSizeMenu [AddItem (oneof :PenSizeMenuItem "Size [15 15])]
  400. ask :PenSizeMenu [AddItem (oneof MenuItem "Title "|(-|)]
  401. ask :PenSizeMenu [AddItem (oneof :WSizeMenuItem)]
  402. ask :PenSizeMenu [AddItem (oneof :HSizeMenuItem)]
  403.  
  404.  
  405. to SetThePenSize
  406.   LocalMake "PenSizePicked ask ActionMenuItem [:MyPenSize]
  407.   LocalMake "ATurtle first ask :CurrentTurtleWindow [Turtles]
  408.   ask :ATurtle
  409. _  [SetPenSize first :PenSizePicked last :PenSizePicked]
  410.   ask :CurrentTurtleWindow [SaveIt "SetPenSize]
  411.   ask :CurrentTurtleWindow [SaveIt first :PenSizePicked]
  412.   ask :CurrentTurtleWindow [SaveIt last :PenSizePicked]
  413. end
  414.  
  415. to SetThePenWidth
  416.   LocalMake "ATurtle first ask :CurrentTurtleWindow [Turtles]
  417.   LocalMake "Width first ask :ATurtle [PenSize]
  418.   LocalMake "Height last ask :ATurtle [PenSize]
  419.   LocalMake "Msg
  420. _   "|Enter the pen width (a number between 0 and 127). |
  421.   LocalMake "Result DialogWord :Msg :Width []
  422.   if EqualP first :Result "Cancel [stop]
  423.   if (or (not NumberP  last :Result)
  424. _       (LessP last :Result 0)
  425. _       (GreaterP last :Result 127))
  426. _   [stop]
  427.   ask :ATurtle [SetPenSize last :Result :Height]
  428.   ask :CurrentTurtleWindow [SaveIt "SetPenSize]
  429.   ask :CurrentTurtleWindow [SaveIt last :Result]
  430.   ask :CurrentTurtleWindow [SaveIt :Height]
  431. end
  432.  
  433. to SetThePenHeight
  434.   LocalMake "ATurtle first ask :CurrentTurtleWindow [Turtles]
  435.   LocalMake "Width first ask :ATurtle [PenSize]
  436.   LocalMake "Height last ask :ATurtle [PenSize]
  437.   LocalMake "Msg
  438. _   "|Enter the pen height (a number between 0 and 127). |
  439.   LocalMake "Result DialogWord :Msg :Height []
  440.   if EqualP first :Result "Cancel [stop]
  441.   if (or (not NumberP  last :Result)
  442. _       (LessP last :Result 0)
  443. _       (GreaterP last :Result 127))
  444. _   [stop]
  445.   ask :ATurtle [SetPenSize :Width last :Result]
  446.   ask :CurrentTurtleWindow [SaveIt "SetPenSize]
  447.   ask :CurrentTurtleWindow [SaveIt :Width]
  448.   ask :CurrentTurtleWindow [SaveIt last :Result]
  449. end
  450.  
  451.  
  452. ;
  453. ;-------- Windows Menu
  454. ;
  455. make "WindowMenu oneof Menu
  456. ask :WindowMenu [SetTitle "Windows]
  457.  
  458. ask :WindowMenu [to Select :WhichOne]
  459.   make "CurrentTurtleWindow (Item :WhichOne (DrawingWindows Windows []))
  460.   ask :CurrentTurtleWindow [WSelect]
  461.   SetDefaultTurtle ask :CurrentTurtleWindow [:TheTurtle]
  462.   ask :ControlPanel [WSelect]
  463. end
  464.  
  465. ask :WindowMenu [to Update]
  466.   RemoveAllItems ItemList
  467.   AddDrawingWindows DrawingWindows Windows []
  468. end
  469.  
  470. to RemoveAllItems :TheItems
  471.   if EmptyP :TheItems [stop]
  472.   RemoveItem first :TheItems
  473.   RemoveAllItems butfirst :TheItems
  474. end
  475.  
  476. to AddDrawingWindows :WindowsToAdd
  477.   if EmptyP :WindowsToAdd [stop]
  478.   LocalMake "Temp oneof MenuItem
  479.   ask :Temp [SetTitle ask first :WindowsToAdd [WTitle]]
  480.   AddItem :Temp
  481.   AddDrawingWindows butfirst :WindowsToAdd
  482. end
  483.  
  484. to DrawingWindows :AllWindows :OnlyDrawing
  485.   if EmptyP :AllWindows
  486. _    [output :OnlyDrawing]
  487.   if (ask first :AllWindows [MyNameP "TheTurtle])
  488. _    [Make "OnlyDrawing sentence :OnlyDrawing first :AllWindows]
  489.   DrawingWindows butfirst :AllWindows :OnlyDrawing
  490. end
  491.  
  492.  
  493.  
  494. ;
  495. ;  Install Menus
  496. ;
  497. to InstallNewMenu
  498.   ClearMenuBar
  499.   ask :NewAppleMenu [Install]
  500.   ask :FileMenu [Install]
  501.   ask :EditMenu [Install]
  502.   ;ask :EditMenu [Disable]          ;no edit menu for our game
  503.   ask :RecorderMenu [Install]
  504.   ask :TurtleMenu [Install]
  505.   ask :PatternMenu [Install]
  506.   ask :PenModeMenu [Install]
  507.   ask :PenSizeMenu [Install]
  508.   ask :WindowMenu [Install]
  509. end
  510.  
  511.  
  512.  
  513. ;
  514. ;  P R O C E D U R E S    I N V O K E D    F R O M    M E N U
  515. ;
  516.  
  517. to MakeNewWindow
  518.   make "CurrentTurtleWindow (oneof :DrawingWindow "ProcID 4 "CloseP "False)
  519.   make "TurtleWindowID :TurtleWindowID + 1
  520.   ask :CurrentTurtleWindow [SetWTitle (word "|Turtle Window | :TurtleWindowID)]
  521.   SetDefaultTurtle ask :CurrentTurtleWindow [:TheTurtle]
  522.   ask :CurrentTurtleWindow [ShowTurtle]
  523.   ask :ControlPanel [WSelect]
  524. end
  525.  
  526. to DoPrint
  527.   if EmptyP :CurrentTurtleWindow [stop]
  528.   ask :CurrentTurtleWindow [HardCopy]
  529. end
  530.  
  531. to DoQuit
  532.   make "TurtleWindowID 0
  533.   Make "CurrentTurtleWindow []
  534.   CleanUpToQuit Windows
  535.   SetMenuBar DefaultMenuBar
  536.   TopLevel
  537. end
  538.  
  539. to GetNumber
  540.   LocalMake "Msg
  541. _   "|How many times to you wish to repeat the commands? |
  542.   LocalMake "Result  DialogWord :Msg 1 []
  543.   Output :Result
  544. end
  545.  
  546.  
  547. ;
  548. ;  C O N T R O L W I N D O W    O B J E C T    D E F I N I T I ON
  549. ;
  550.  
  551. make "ControlWindow kindof TurtleWindow
  552.  
  553. ask :ControlWindow [to exist]
  554.   Usual.Exist
  555.   SetWPos [3 30]
  556.   SetWSize [90 300]
  557.   SetWFont "Monaco
  558.   SetWFontSize 9
  559.   DrawControlBoxes
  560.   HaveMake "CurrentCommand "||     ;the Command most recently selected
  561.   HaveMake "CurrentDistance "||    ;the distance most recently entered
  562.   HaveMake "CurrentAngle "||       ;the angle most recently entered
  563.   HaveMake "CurrentParameter "Distance
  564.   HaveMake "PointClicked []
  565. end
  566.  
  567. ;
  568. ;  Draw a box in the specified rectangle and place the text in the box.
  569. ;  Output the rectangle.
  570. ;
  571. ask :ControlWindow [to MakeBox :Rect :Label]
  572.   FrameRect :Rect
  573.   MoveTo (Item 1 :Rect) + 4  (Item 2 :Rect) + 11
  574.   Type :Label
  575.   Output :Rect
  576. end
  577.  
  578. ;
  579. ;  Draw all ControlWindow boxes.  
  580. ;  Define ControlWindow object variables for each box.
  581. ;
  582. ask :ControlWindow [to DrawControlBoxes]
  583.   HaveMake "MoveRect MakeBox [5 20 85 35] "||         ;Turtle movement 
  584.   InvertRect (InsetRect :MoveRect 1 1)
  585.   HaveMake "FdRect MakeBox [5 40 85 55] "Forward
  586.   HaveMake "BkRect MakeBox [5 55 85 70] "Back
  587.   HaveMake "LtRect MakeBox [5 70 85 85] "Left
  588.   HaveMake "RtRect MakeBox [5 85 85 100] "Right
  589.   HaveMake "CSRect MakeBox [5 100 45 115] "CS
  590.   HaveMake "HomeRect MakeBox [45 100 85 115] "Home
  591.   MoveTo 7 141
  592.   Type "|Dist.|
  593.   MoveTo 49 141
  594.   Type "|Angle|
  595.   HaveMake "DistRect MakeBox [5 145 43 160] "||       ;Distance Entry
  596.   HaveMake "AngleRect MakeBox [47 145 85 160] "||     ;Angle Entry 
  597.   InvertRect (InsetRect :DistRect 1 1)
  598.   InvertRect (InsetRect :AngleRect 1 1)
  599.   HaveMake "D0Rect MakeBox [5 165 45 180] "|  0 |
  600.   HaveMake "D5Rect MakeBox [45 165 85 180] "|  5 |
  601.   HaveMake "D1Rect MakeBox [5 180 45 195] "|  1 |
  602.   HaveMake "D6Rect MakeBox [45 180 85 195] "|  6 |
  603.   HaveMake "D2Rect MakeBox [5 195 45 210] "|  2 |
  604.   HaveMake "D7Rect MakeBox [45 195 85 210] "|  7 |
  605.   HaveMake "D3Rect MakeBox [5 210 45 225] "|  3 |
  606.   HaveMake "D8Rect MakeBox [45 210 85 225] "|  8 |
  607.   HaveMake "D4Rect MakeBox [5 225 45 240] "|  4 |
  608.   HaveMake "D9Rect MakeBox [45 225 85 240] "|  9 |
  609.   HaveMake "EraseRect MakeBox [5 240 85 255] "|   Erase|
  610.   
  611.   HaveMake "RunRect MakeBox [5 275 85 290] "|  ** RUN **|
  612.  
  613.   HaveMake "CmdRect [5 40 85 115]                    ;Enclose commands
  614.   HaveMake "NumberRect [5 165 85 240]                ;Enclose digits
  615. end
  616.  
  617. ;
  618. ;  Handle clicks in the Control Window
  619. ;
  620. ask :ControlWindow [to WClick :X :Y :Mods]
  621.   HaveMake "PointClicked list :X :Y
  622.   HandleClick :PointClicked
  623.   Usual.WClick :X :Y :Mods
  624. end
  625.  
  626. ask :ControlWindow [to HandleClick :ThePoint]
  627.   if PtInRectP :ThePoint :CmdRect [DoCmd]
  628.   if PtInRectP :ThePoint :NumberRect [DoNumber]
  629.   if PtInRectP :ThePoint :EraseRect [DoErase]
  630.   if PtInRectP :ThePoint :RunRect [DoRun]
  631. end
  632.  
  633. ;
  634. ;  Flash the box in which the mouse button was clicked.
  635. ;  (Clicks are simple-minded.  No check is made to see if the mouse
  636. ;   button is released in the same button as the click.)
  637. ;
  638. ask :ControlWindow [to FlashRect :Rect]
  639.   InvertRect (InsetRect :Rect 1 1)
  640.   wait .25
  641.   InvertRect (InsetRect :Rect 1 1)
  642. end
  643.  
  644. ;
  645. ;  Process turtle movement commands.  Store the selected command an
  646. ;  object variable.
  647. ;
  648. ask :ControlWindow [to DoCmd]
  649.   if PtInRectP :PointClicked :FdRect
  650. _    [SetCommand  :FdRect "Forward
  651. _     HaveMake "CurrentParameter "Distance]
  652.   if PtInRectP :PointClicked :BkRect
  653. _    [SetCommand :BkRect "Back
  654. _     HaveMake "CurrentParameter "Distance]
  655.   if PtInRectP :PointClicked :LtRect
  656. _    [SetCommand :LtRect "Left
  657. _     HaveMake "CurrentParameter "Angle]
  658.   if PtInRectP :PointClicked :RtRect
  659. _    [SetCommand :RtRect "Right
  660. _     HaveMake "CurrentParameter "Angle]
  661.   if PtInRectP :PointClicked :CSRect
  662. _    [SetCommand :CSRect "ClearScreen]
  663.   if PtInRectP :PointClicked :HomeRect
  664. _    [SetCommand :HomeRect "Home]
  665. end
  666.  
  667. ask :ControlWindow [to SetCommand :Rect :Command]
  668.   FlashRect :Rect
  669.   HaveMake "CurrentCommand :Command
  670.   DisplayCommand :Command
  671. end
  672.  
  673. ;
  674. ;  Display the selected command.
  675. ;
  676. ask :ControlWindow [to DisplayCommand :Command]
  677.   EraseRect (InsetRect :MoveRect 1 1)
  678.   MoveTo (Item 1 :MoveRect) + 4  (Item 2 :MoveRect) + 11
  679.   Type :Command
  680.   InvertRect (InsetRect :MoveRect 1 1)
  681. end
  682.  
  683. ;
  684. ;  Process digit clicks.  Assemble the digits into a result field.
  685. ;
  686. ask :ControlWindow [to DoNumber]
  687.   if PtInRectP :PointClicked :D0Rect [DoDigit :D0Rect 0]
  688.   if PtInRectP :PointClicked :D1Rect [DoDigit :D1Rect 1]
  689.   if PtInRectP :PointClicked :D2Rect [DoDigit :D2Rect 2]
  690.   if PtInRectP :PointClicked :D3Rect [DoDigit :D3Rect 3]
  691.   if PtInRectP :PointClicked :D4Rect [DoDigit :D4Rect 4]
  692.   if PtInRectP :PointClicked :D5Rect [DoDigit :D5Rect 5]
  693.   if PtInRectP :PointClicked :D6Rect [DoDigit :D6Rect 6]
  694.   if PtInRectP :PointClicked :D7Rect [DoDigit :D7Rect 7]
  695.   if PtInRectP :PointClicked :D8Rect [DoDigit :D8Rect 8]
  696.   if PtInRectP :PointClicked :D9Rect [DoDigit :D9Rect 9]
  697. end
  698.   
  699. ask :ControlWindow [to DoDigit :Rect :Digit]
  700.   FlashRect :Rect
  701.   if EqualP :CurrentParameter "Distance
  702. _   [HaveMake "CurrentDistance word :CurrentDistance :Digit
  703. _    if GreaterP  (count :CurrentDistance) 3
  704. _      [HaveMake "CurrentDistance butfirst :CurrentDistance]
  705. _    DisplayNumber :CurrentDistance :DistRect]
  706.   if EqualP :CurrentParameter "Angle
  707. _   [HaveMake "CurrentAngle word :CurrentAngle :Digit
  708. _    if GreaterP  (count :CurrentAngle) 3
  709. _      [HaveMake "CurrentAngle butfirst :CurrentAngle]
  710. _    DisplayNumber :CurrentAngle :AngleRect]
  711. end
  712.  
  713. ask :ControlWindow [to DisplayNumber :Number :Rect]
  714.   EraseRect (InsetRect :Rect 1 1)
  715.   MoveTo (Item 1 :Rect) + 4  (Item 2 :Rect) + 11
  716.   (Type :Number)
  717.   InvertRect (InsetRect :Rect 1 1)
  718. end
  719.  
  720. ;
  721. ;  Erase the integer entered so far.
  722. ;
  723. ask :ControlWindow [to DoErase]
  724.   FlashRect :EraseRect
  725.   if Equalp :CurrentParameter "Distance
  726. _   [make "CurrentDistance "||
  727. _    DisplayNumber :CurrentDistance :DistRect]
  728.   if Equalp :CurrentParameter "Angle
  729. _   [make "CurrentAngle "||
  730. _    DisplayNumber :CurrentAngle :AngleRect]
  731.  
  732. end
  733.  
  734. ;
  735. ;  Run the currently entered procedure.
  736. ;  The gobal variable CurrentTurtleWindow contains the most recently
  737. ;  created turtle window.
  738. ;
  739. ask :ControlWindow [to DoRun]
  740.   LocalMake "Cmd :CurrentCommand
  741.   LocalMake "Dist :CurrentDistance
  742.   LocalMake "Angle :CurrentAngle
  743.   if or (EmptyP :CurrentTurtleWindow)
  744. _       (EmptyP :Cmd)
  745. _   [stop] 
  746.   FlashRect :RunRect
  747.   if EqualP :Cmd "ClearScreen [RunCS]
  748.   if EqualP :Cmd "Home [RunHome]
  749.   if EqualP :Cmd "Forward [RunFd :Dist]
  750.   if Equalp :Cmd "Back [RunBk :Dist]
  751.   if EqualP :Cmd "Left [RunLt :Angle]
  752.   if EqualP :Cmd "Right [RunRt :Angle]
  753. end
  754.  
  755. ask :ControlWindow [to RunCS]
  756.   ask :CurrentTurtleWindow [ClearScreen]
  757.   ask :CurrentTurtleWindow [SaveIt "ClearScreen]
  758. end
  759.  
  760. ask :ControlWindow [to RunHome]
  761.   ask :CurrentTurtleWindow [Home]
  762.   ask :CurrentTurtleWindow [SaveIt "Home]
  763. end
  764.  
  765. ask :ControlWindow [to RunFd :Dist]
  766.   ask :CurrentTurtleWindow [Fd :Dist]
  767.   ask :CurrentTurtleWindow [SaveIt "Fd]
  768.   ask :CurrentTurtleWindow [SaveIt :Dist]
  769. end
  770.  
  771. ask :ControlWindow [to RunBk :Dist]
  772.   ask :CurrentTurtleWindow [Bk :Dist]
  773.   ask :CurrentTurtleWindow [SaveIt "Bk]
  774.   ask :CurrentTurtleWindow [SaveIt :Dist]
  775. end
  776.  
  777. ask :ControlWindow [to RunRt :Angle]
  778.   ask :CurrentTurtleWindow [Rt :Angle]
  779.   ask :CurrentTurtleWindow [SaveIt "Rt]
  780.   ask :CurrentTurtleWindow [SaveIt :Angle]
  781. end
  782.  
  783. ask :ControlWindow [to RunLt :Angle]
  784.   ask :CurrentTurtleWindow [Lt :Angle]
  785.   ask :CurrentTurtleWindow [SaveIt "Lt]
  786.   ask :CurrentTurtleWindow [SaveIt :Angle]
  787. end
  788.  
  789.  
  790. ;
  791. ;  D R A W I N G W I N D O W    O B J E C T    D E F I N I T I O N
  792. ;
  793.  
  794. make "DrawingWindow kindof TurtleWindow
  795.  
  796. ask :DrawingWindow [to exist]
  797.   Usual.Exist
  798.   SetWpos [98 40]
  799.   SetWSize [410 295]
  800.   HaveMake "TheTurtle OneOf Turtle
  801.   HaveMake "MyPattern "Black
  802.   HaveMake "DrawingHistory []        ;Record of turtle commands
  803.   HaveMake "RecordingP "False        ;Initially not recording
  804. end
  805.  
  806. ask :DrawingWindow [to SaveIt :CommandWord]
  807.   if not :RecordingP [stop]
  808.   HaveMake "DrawingHistory lput :CommandWord :DrawingHistory
  809. end
  810.  
  811. ;
  812. ;  Let's start!
  813.  
  814. GO